home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / lib / srfi-9.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  8.8 KB  |  262 lines
  1. ;; Copyright (C) Richard Kelsey (1999). All Rights Reserved.
  2. ;; 
  3. ;; Permission is hereby granted, free of charge, to any person obtaining
  4. ;; a copy of this software and associated documentation files (the
  5. ;; "Software"), to deal in the Software without restriction, including
  6. ;; without limitation the rights to use, copy, modify, merge, publish,
  7. ;; distribute, sublicense, and/or sell copies of the Software, and to
  8. ;; permit persons to whom the Software is furnished to do so, subject to
  9. ;; the following conditions:
  10. ;; 
  11. ;; The above copyright notice and this permission notice shall be
  12. ;; included in all copies or substantial portions of the Software.
  13. ;; 
  14. ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  15. ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  16. ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  17. ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  18. ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  19. ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  20. ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  21.  
  22.  
  23. ;; ChangeLog
  24. ;;
  25. ;; 2007-07-23 yamaken   - Imported from
  26. ;;                        http://srfi.schemers.org/srfi-9/srfi-9.html
  27. ;;                        and adapted to SigScheme
  28. ;; 2007-09-04 yamaken   - Fix  (real-eval `(lambda (vector?) ,exp))
  29. ;;                        with (real-eval `(lambda (vector?) ,exp) env)
  30. ;;                      - Suppress overriding of 'eval' since current SigScheme
  31. ;;                        implementation (0.8.0) does not need the vector?
  32. ;;                        trick. It allows (interaction-environment).
  33.  
  34.  
  35. ;; This code is divided into three layers. In top-down order these are:
  36. ;; 
  37. ;;    1. Syntax definitions for DEFINE-RECORD-TYPE and an auxillary macro.
  38. ;;    2. An implementation of record types with a procedural interface. Some
  39. ;;       Scheme implementations already have something close to this.
  40. ;;    3. Vector-like records implemented in R5RS. This redefines some standard
  41. ;;       Scheme procedures and therefor must be loaded before any other code,
  42. ;;       including part 2 above. Note that these procedures can be used to
  43. ;;       break the record-type abstraction (for example, RECORD-SET! can be
  44. ;;       used to modify the type of a record). Access to these procedures
  45. ;;       should be restricted.
  46.  
  47.  
  48. ;;
  49. ;; Syntax definitions
  50. ;;
  51.  
  52. ; Definition of DEFINE-RECORD-TYPE
  53.  
  54. ;;(define-syntax define-record-type
  55. ;;  (syntax-rules ()
  56. ;;    ((define-record-type type
  57. ;;       (constructor constructor-tag ...)
  58. ;;       predicate
  59. ;;       (field-tag accessor . more) ...)
  60. ;;     (begin
  61. ;;       (define type
  62. ;;         (make-record-type 'type '(field-tag ...)))
  63. ;;       (define constructor
  64. ;;         (record-constructor type '(constructor-tag ...)))
  65. ;;       (define predicate
  66. ;;         (record-predicate type))
  67. ;;       (define-record-field type field-tag accessor . more)
  68. ;;       ...))))
  69.  
  70. ; An auxilliary macro for define field accessors and modifiers.
  71. ; This is needed only because modifiers are optional.
  72.  
  73. ;;(define-syntax define-record-field
  74. ;;  (syntax-rules ()
  75. ;;    ((define-record-field type field-tag accessor)
  76. ;;     (define accessor (record-accessor type 'field-tag)))
  77. ;;    ((define-record-field type field-tag accessor modifier)
  78. ;;     (begin
  79. ;;       (define accessor (record-accessor type 'field-tag))
  80. ;;       (define modifier (record-modifier type 'field-tag))))))
  81.  
  82.  
  83. ;;
  84. ;; Records
  85. ;;
  86.  
  87. ; This implements a record abstraction that is identical to vectors,
  88. ; except that they are not vectors (VECTOR? returns false when given a
  89. ; record and RECORD? returns false when given a vector).  The following
  90. ; procedures are provided:
  91. ;   (record? <value>)                -> <boolean>
  92. ;   (make-record <size>)             -> <record>
  93. ;   (record-ref <record> <index>)    -> <value>
  94. ;   (record-set! <record> <index> <value>) -> <unspecific>
  95. ;
  96. ; These can implemented in R5RS Scheme as vectors with a distinguishing
  97. ; value at index zero, providing VECTOR? is redefined to be a procedure
  98. ; that returns false if its argument contains the distinguishing record
  99. ; value.  EVAL is also redefined to use the new value of VECTOR?.
  100.  
  101. ; Define the marker and redefine VECTOR? and EVAL.
  102.  
  103. (define record-marker (list 'record-marker))
  104.  
  105. (define real-vector? vector?)
  106.  
  107. (define (vector? x)
  108.   (and (real-vector? x)
  109.        (or (= 0 (vector-length x))
  110.        (not (eq? (vector-ref x 0)
  111.         record-marker)))))
  112.  
  113. (cond-expand
  114.  (sigscheme
  115.   ;; Current SigScheme implementation does not need the vector? trick.
  116.   #t)
  117.  (else
  118. ; This won't work if ENV is the interaction environment and someone has
  119. ; redefined LAMBDA there.
  120.  
  121. (define eval
  122.   (let ((real-eval eval))
  123.     (lambda (exp env)
  124.       ((real-eval `(lambda (vector?) ,exp) env)
  125.        vector?))))
  126. ))
  127.  
  128. ; Definitions of the record procedures.
  129.  
  130. (define (record? x)
  131.   (and (real-vector? x)
  132.        (< 0 (vector-length x))
  133.        (eq? (vector-ref x 0)
  134.             record-marker)))
  135.  
  136. (define (make-record size)
  137.   (let ((new (make-vector (+ size 1))))
  138.     (vector-set! new 0 record-marker)
  139.     new))
  140.  
  141. (define (record-ref record index)
  142.   (vector-ref record (+ index 1)))
  143.  
  144. (define (record-set! record index value)
  145.   (vector-set! record (+ index 1) value))
  146.  
  147.  
  148. ;;
  149. ;; Record types
  150. ;;
  151.  
  152. ; We define the following procedures:
  153. ; 
  154. ; (make-record-type <type-name> <field-names>)     -> <record-type>
  155. ; (record-constructor <record-type> <field-names>) -> <constructor>
  156. ; (record-predicate <record-type>)                 -> <predicate>
  157. ; (record-accessor <record-type <field-name>)      -> <accessor>
  158. ; (record-modifier <record-type <field-name>)      -> <modifier>
  159. ;   where
  160. ; (<constructor> <initial-value> ...)         -> <record>
  161. ; (<predicate> <value>)                       -> <boolean>
  162. ; (<accessor> <record>)                       -> <value>
  163. ; (<modifier> <record> <value>)         -> <unspecific>
  164.  
  165. ; Record types are implemented using vector-like records.  The first
  166. ; slot of each record contains the record's type, which is itself a
  167. ; record.
  168.  
  169. (define (record-type record)
  170.   (record-ref record 0))
  171.  
  172. ;----------------
  173. ; Record types are themselves records, so we first define the type for
  174. ; them.  Except for problems with circularities, this could be defined as:
  175. ;  (define-record-type :record-type
  176. ;    (make-record-type name field-tags)
  177. ;    record-type?
  178. ;    (name record-type-name)
  179. ;    (field-tags record-type-field-tags))
  180. ; As it is, we need to define everything by hand.
  181.  
  182. (define :record-type (make-record 3))
  183. (record-set! :record-type 0 :record-type)    ; Its type is itself.
  184. (record-set! :record-type 1 ':record-type)
  185. (record-set! :record-type 2 '(name field-tags))
  186.  
  187. ; Now that :record-type exists we can define a procedure for making more
  188. ; record types.
  189.  
  190. (define (make-record-type name field-tags)
  191.   (let ((new (make-record 3)))
  192.     (record-set! new 0 :record-type)
  193.     (record-set! new 1 name)
  194.     (record-set! new 2 field-tags)
  195.     new))
  196.  
  197. ; Accessors for record types.
  198.  
  199. (define (record-type-name record-type)
  200.   (record-ref record-type 1))
  201.  
  202. (define (record-type-field-tags record-type)
  203.   (record-ref record-type 2))
  204.  
  205. ;----------------
  206. ; A utility for getting the offset of a field within a record.
  207.  
  208. (define (field-index type tag)
  209.   (let loop ((i 1) (tags (record-type-field-tags type)))
  210.     (cond ((null? tags)
  211.            (error "record type has no such field" type tag))
  212.           ((eq? tag (car tags))
  213.            i)
  214.           (else
  215.            (loop (+ i 1) (cdr tags))))))
  216.  
  217. ;----------------
  218. ; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
  219. ; procedures used by the macro expansion of DEFINE-RECORD-TYPE.
  220.  
  221. (define (record-constructor type tags)
  222.   (let ((size (length (record-type-field-tags type)))
  223.         (arg-count (length tags))
  224.         (indexes (map (lambda (tag)
  225.                         (field-index type tag))
  226.                       tags)))
  227.     (lambda args
  228.       (if (= (length args)
  229.              arg-count)
  230.           (let ((new (make-record (+ size 1))))
  231.             (record-set! new 0 type)
  232.             (for-each (lambda (arg i)
  233.             (record-set! new i arg))
  234.                       args
  235.                       indexes)
  236.             new)
  237.           (error "wrong number of arguments to constructor" type args)))))
  238.  
  239. (define (record-predicate type)
  240.   (lambda (thing)
  241.     (and (record? thing)
  242.          (eq? (record-type thing)
  243.               type))))
  244.  
  245. (define (record-accessor type tag)
  246.   (let ((index (field-index type tag)))
  247.     (lambda (thing)
  248.       (if (and (record? thing)
  249.                (eq? (record-type thing)
  250.                     type))
  251.           (record-ref thing index)
  252.           (error "accessor applied to bad value" type tag thing)))))
  253.  
  254. (define (record-modifier type tag)
  255.   (let ((index (field-index type tag)))
  256.     (lambda (thing value)
  257.       (if (and (record? thing)
  258.                (eq? (record-type thing)
  259.                     type))
  260.           (record-set! thing index value)
  261.           (error "modifier applied to bad value" type tag thing)))))
  262.